home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / smtpmail.el.z / smtpmail.el
Encoding:
Text File  |  1998-10-28  |  15.7 KB  |  526 lines
  1. ;; Simple SMTP protocol (RFC 821) for sending mail
  2.  
  3. ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
  6. ;; Maintainer: Brian D. Carlstrom <bdc@ai.mit.edu>
  7. ;; Keywords: mail
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; Send Mail to smtp host from smtpmail temp buffer.
  29.  
  30. ;; Please add these lines in your .emacs(_emacs).
  31. ;;
  32. ;;(setq send-mail-function 'smtpmail-send-it)
  33. ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST")
  34. ;;(setq smtpmail-smtp-service "smtp")
  35. ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME")
  36. ;;(setq smtpmail-debug-info t)
  37. ;;(load-library "smtpmail")
  38. ;;(setq smtpmail-code-conv-from nil)
  39. ;;(setq user-full-name "YOUR NAME HERE")
  40.  
  41. ;;; Code:
  42.  
  43. (require 'sendmail)
  44.  
  45. ;;;
  46. (defvar smtpmail-default-smtp-server nil
  47.   "*Specify default SMTP server.")
  48.  
  49. (defvar smtpmail-smtp-server 
  50.   (or (getenv "SMTPSERVER") smtpmail-default-smtp-server)
  51.   "*The name of the host running SMTP server.")
  52.  
  53. (defvar smtpmail-smtp-service 25
  54.   "*SMTP service port number. smtp or 25 .")
  55.  
  56. (defvar smtpmail-local-domain nil
  57.   "*Local domain name without a host name.
  58. If the function (system-name) returns the full internet address,
  59. don't define this value.")
  60.  
  61. (defvar smtpmail-debug-info nil
  62.   "*smtpmail debug info printout. messages and process buffer.")
  63.  
  64. (defvar smtpmail-code-conv-from nil ;; *junet*
  65.   "*smtpmail code convert from this code to *internal*..for tiny-mime..")
  66.  
  67. ;;;
  68. ;;;
  69. ;;;
  70.  
  71. (defun smtpmail-send-it ()
  72.   (require 'mail-utils)
  73.   (let ((errbuf (if mail-interactive
  74.             (generate-new-buffer " smtpmail errors")
  75.           0))
  76.     (tembuf (generate-new-buffer " smtpmail temp"))
  77.     (case-fold-search nil)
  78.     resend-to-addresses
  79.     delimline
  80.     (mailbuf (current-buffer)))
  81.     (unwind-protect
  82.     (save-excursion
  83.       (set-buffer tembuf)
  84.       (erase-buffer)
  85.       (insert-buffer-substring mailbuf)
  86.       (goto-char (point-max))
  87.       ;; require one newline at the end.
  88.       (or (= (preceding-char) ?\n)
  89.           (insert ?\n))
  90.       ;; Change header-delimiter to be what sendmail expects.
  91.       (goto-char (point-min))
  92.       (re-search-forward
  93.         (concat "^" (regexp-quote mail-header-separator) "\n"))
  94.       (replace-match "\n")
  95.       (backward-char 1)
  96.       (setq delimline (point-marker))
  97. ;;      (sendmail-synch-aliases)
  98.       (if mail-aliases
  99.           (expand-mail-aliases (point-min) delimline))
  100.       (goto-char (point-min))
  101.       ;; ignore any blank lines in the header
  102.       (while (and (re-search-forward "\n\n\n*" delimline t)
  103.               (< (point) delimline))
  104.         (replace-match "\n"))
  105.       (let ((case-fold-search t))
  106.         (goto-char (point-min))
  107.         (goto-char (point-min))
  108.         (while (re-search-forward "^Resent-to:" delimline t)
  109.           (setq resend-to-addresses
  110.             (save-restriction
  111.               (narrow-to-region (point)
  112.                     (save-excursion
  113.                       (end-of-line)
  114.                       (point)))
  115.               (append (mail-parse-comma-list)
  116.                   resend-to-addresses))))
  117. ;;; Apparently this causes a duplicate Sender.
  118. ;;;        ;; If the From is different than current user, insert Sender.
  119. ;;;        (goto-char (point-min))
  120. ;;;        (and (re-search-forward "^From:"  delimline t)
  121. ;;;         (progn
  122. ;;;           (require 'mail-utils)
  123. ;;;           (not (string-equal
  124. ;;;             (mail-strip-quoted-names
  125. ;;;              (save-restriction
  126. ;;;                (narrow-to-region (point-min) delimline)
  127. ;;;                (mail-fetch-field "From")))
  128. ;;;             (user-login-name))))
  129. ;;;         (progn
  130. ;;;           (forward-line 1)
  131. ;;;           (insert "Sender: " (user-login-name) "\n")))
  132.         ;; Don't send out a blank subject line
  133.         (goto-char (point-min))
  134.         (if (re-search-forward "^Subject:[ \t]*\n" delimline t)
  135.         (replace-match ""))
  136.         ;; Put the "From:" field in unless for some odd reason
  137.         ;; they put one in themselves.
  138.         (goto-char (point-min))
  139.         (if (not (re-search-forward "^From:" delimline t))
  140.         (let* ((login user-mail-address)
  141.                (fullname (user-full-name)))
  142.           (cond ((eq mail-from-style 'angles)
  143.              (insert "From: " fullname)
  144.              (let ((fullname-start (+ (point-min) 6))
  145.                    (fullname-end (point-marker)))
  146.                (goto-char fullname-start)
  147.                ;; Look for a character that cannot appear unquoted
  148.                ;; according to RFC 822.
  149.                (if (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
  150.                           fullname-end 1)
  151.                    (progn
  152.                  ;; Quote fullname, escaping specials.
  153.                  (goto-char fullname-start)
  154.                  (insert "\"")
  155.                  (while (re-search-forward "[\"\\]"
  156.                                fullname-end 1)
  157.                    (replace-match "\\\\\\&" t))
  158.                  (insert "\""))))
  159.              (insert " <" login ">\n"))
  160.             ((eq mail-from-style 'parens)
  161.              (insert "From: " login " (")
  162.              (let ((fullname-start (point)))
  163.                (insert fullname)
  164.                (let ((fullname-end (point-marker)))
  165.                  (goto-char fullname-start)
  166.                  ;; RFC 822 says \ and nonmatching parentheses
  167.                  ;; must be escaped in comments.
  168.                  ;; Escape every instance of ()\ ...
  169.                  (while (re-search-forward "[()\\]" fullname-end 1)
  170.                    (replace-match "\\\\\\&" t))
  171.                  ;; ... then undo escaping of matching parentheses,
  172.                  ;; including matching nested parentheses.
  173.                  (goto-char fullname-start)
  174.                  (while (re-search-forward 
  175.                      "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)"
  176.                      fullname-end 1)
  177.                    (replace-match "\\1(\\3)" t)
  178.                    (goto-char fullname-start))))
  179.              (insert ")\n"))
  180.             ((null mail-from-style)
  181.              (insert "From: " login "\n")))))
  182.         ;; Insert an extra newline if we need it to work around
  183.         ;; Sun's bug that swallows newlines.
  184.         (goto-char (1+ delimline))
  185.         (if (eval mail-mailer-swallows-blank-line)
  186.         (newline))
  187.         ;; Find and handle any FCC fields.
  188.         (goto-char (point-min))
  189.         (if (re-search-forward "^FCC:" delimline t)
  190.         (mail-do-fcc delimline))
  191.         (if mail-interactive
  192.         (save-excursion
  193.           (set-buffer errbuf)
  194.           (erase-buffer))))
  195.       ;;
  196.       ;;
  197.       ;;
  198.       (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*"))
  199.       (setq smtpmail-recipient-address-list
  200.         (or resend-to-addresses
  201.             (smtpmail-deduce-address-list tembuf (point-min) delimline)))
  202.       (kill-buffer smtpmail-address-buffer)
  203.  
  204.       (smtpmail-do-bcc delimline)
  205.  
  206.       (if (not (null smtpmail-recipient-address-list))
  207.           (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf))
  208.           (error "Sending failed; SMTP protocol error"))
  209.         (error "Sending failed; no recipients"))
  210.       )
  211.       (kill-buffer tembuf)
  212.       (if (bufferp errbuf)
  213.       (kill-buffer errbuf)))))
  214.  
  215.  
  216. ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer)
  217.  
  218. (defun smtpmail-fqdn ()
  219.   (if smtpmail-local-domain
  220.       (concat (system-name) "." smtpmail-local-domain)
  221.     (system-name)))
  222.  
  223. (defun smtpmail-via-smtp (recipient smtpmail-text-buffer)
  224.   (let ((process nil)
  225.     (host smtpmail-smtp-server)
  226.     (port smtpmail-smtp-service)
  227.     response-code
  228.     greeting
  229.     process-buffer)
  230.     (unwind-protect
  231.     (catch 'done
  232.       ;; get or create the trace buffer
  233.       (setq process-buffer
  234.         (get-buffer-create (format "*trace of SMTP session to %s*" host)))
  235.  
  236.       ;; clear the trace buffer of old output
  237.       (save-excursion
  238.         (set-buffer process-buffer)
  239.         (erase-buffer))
  240.  
  241.       ;; open the connection to the server
  242.       (setq process (open-network-stream "SMTP" process-buffer host port))
  243.       (and (null process) (throw 'done nil))
  244.  
  245.       ;; set the send-filter
  246.       (set-process-filter process 'smtpmail-process-filter)
  247.  
  248.       (save-excursion
  249.         (set-buffer process-buffer)
  250.         (make-local-variable 'smtpmail-read-point)
  251.         (setq smtpmail-read-point (point-min))
  252.  
  253.         
  254.         (if (or (null (car (setq greeting (smtpmail-read-response process))))
  255.             (not (integerp (car greeting)))
  256.             (>= (car greeting) 400))
  257.         (throw 'done nil)
  258.           )
  259.  
  260.         ;; HELO
  261.         (smtpmail-send-command process (format "HELO %s" (smtpmail-fqdn)))
  262.  
  263.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  264.             (not (integerp (car response-code)))
  265.             (>= (car response-code) 400))
  266.         (throw 'done nil)
  267.           )
  268.  
  269.         ;; MAIL FROM: <sender>
  270. ;        (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn)))
  271.         (smtpmail-send-command process (format "MAIL FROM: <%s>" user-mail-address))
  272.  
  273.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  274.             (not (integerp (car response-code)))
  275.             (>= (car response-code) 400))
  276.         (throw 'done nil)
  277.           )
  278.         
  279.         ;; RCPT TO: <recipient>
  280.         (let ((n 0))
  281.           (while (not (null (nth n recipient)))
  282.         (smtpmail-send-command process (format "RCPT TO: <%s>" (nth n recipient)))
  283.         (setq n (1+ n))
  284.  
  285.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  286.             (not (integerp (car response-code)))
  287.             (>= (car response-code) 400))
  288.             (throw 'done nil)
  289.           )
  290.         ))
  291.         
  292.         ;; DATA
  293.         (smtpmail-send-command process "DATA")
  294.  
  295.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  296.             (not (integerp (car response-code)))
  297.             (>= (car response-code) 400))
  298.         (throw 'done nil)
  299.           )
  300.  
  301.         ;; Mail contents
  302.         (smtpmail-send-data process smtpmail-text-buffer)
  303.  
  304.         ;;DATA end "."
  305.         (smtpmail-send-command process ".")
  306.  
  307.         (if (or (null (car (setq response-code (smtpmail-read-response process))))
  308.             (not (integerp (car response-code)))
  309.             (>= (car response-code) 400))
  310.         (throw 'done nil)
  311.           )
  312.  
  313.         ;;QUIT
  314. ;        (smtpmail-send-command process "QUIT")
  315. ;        (and (null (car (smtpmail-read-response process)))
  316. ;         (throw 'done nil))
  317.         t ))
  318.       (if process
  319.       (save-excursion
  320.         (set-buffer (process-buffer process))
  321.         (smtpmail-send-command process "QUIT")
  322.         (smtpmail-read-response process)
  323.  
  324. ;        (if (or (null (car (setq response-code (smtpmail-read-response process))))
  325. ;            (not (integerp (car response-code)))
  326. ;            (>= (car response-code) 400))
  327. ;        (throw 'done nil)
  328. ;          )
  329.         (delete-process process))))))
  330.  
  331.  
  332. (defun smtpmail-process-filter (process output)
  333.   (save-excursion
  334.     (set-buffer (process-buffer process))
  335.     (goto-char (point-max))
  336.     (insert output)))
  337.  
  338. (defun smtpmail-read-response (process)
  339.   (let ((case-fold-search nil)
  340.     (response-string nil)
  341.     (response-continue t)
  342.     (return-value '(nil ""))
  343.     match-end)
  344.  
  345. ;    (setq response-string nil)
  346. ;    (setq response-continue t)
  347. ;    (setq return-value '(nil ""))
  348.  
  349.     (while response-continue
  350.       (goto-char smtpmail-read-point)
  351.       (while (not (search-forward "\r\n" nil t))
  352.     (accept-process-output process)
  353.     (goto-char smtpmail-read-point))
  354.  
  355.       (setq match-end (point))
  356.       (if (null response-string)
  357.       (setq response-string
  358.         (buffer-substring smtpmail-read-point (- match-end 2))))
  359.     
  360.       (goto-char smtpmail-read-point)
  361.       (if (looking-at "[0-9]+ ")
  362.       (progn (setq response-continue nil)
  363. ;         (setq return-value response-string)
  364.  
  365.          (if smtpmail-debug-info
  366.              (message response-string))
  367.  
  368.          (setq smtpmail-read-point match-end)
  369.          (setq return-value
  370.                (cons (string-to-int 
  371.                   (buffer-substring (match-beginning 0) (match-end 0))) 
  372.                  response-string)))
  373.     
  374.     (if (looking-at "[0-9]+-")
  375.         (progn (setq smtpmail-read-point match-end)
  376.            (setq response-continue t))
  377.       (progn
  378.         (setq smtpmail-read-point match-end)
  379.         (setq response-continue nil)
  380.         (setq return-value 
  381.           (cons nil response-string))
  382.         )
  383.       )))
  384.     (setq smtpmail-read-point match-end)
  385.     return-value))
  386.  
  387.  
  388. (defun smtpmail-send-command (process command)
  389.   (goto-char (point-max))
  390.   (if (= (aref command 0) ?P)
  391.       (insert "PASS <omitted>\r\n")
  392.     (insert command "\r\n"))
  393.   (setq smtpmail-read-point (point))
  394.   (process-send-string process command)
  395.   (process-send-string process "\r\n"))
  396.  
  397. (defun smtpmail-send-data-1 (process data)
  398.   (goto-char (point-max))
  399.  
  400.   (if (not (null smtpmail-code-conv-from))
  401.       (setq data (code-convert-string data smtpmail-code-conv-from *internal*)))
  402.     
  403.   (if smtpmail-debug-info
  404.       (insert data "\r\n"))
  405.  
  406.   (setq smtpmail-read-point (point))
  407.   ;; Escape "." at start of a line
  408.   (if (eq (string-to-char data) ?.)
  409.       (process-send-string process "."))
  410.   (process-send-string process data)
  411.   (process-send-string process "\r\n")
  412.   )
  413.  
  414. (defun smtpmail-send-data (process buffer)
  415.   (let
  416.       ((data-continue t)
  417.        (sending-data nil)
  418.        this-line
  419.        this-line-end)
  420.  
  421.     (save-excursion
  422.       (set-buffer buffer)
  423.       (goto-char (point-min)))
  424.  
  425.     (while data-continue
  426.       (save-excursion
  427.     (set-buffer buffer)
  428.     (beginning-of-line)
  429.     (setq this-line (point))
  430.     (end-of-line)
  431.     (setq this-line-end (point))
  432.     (setq sending-data nil)
  433.     (setq sending-data (buffer-substring this-line this-line-end))
  434.     (if (/= (forward-line 1) 0)
  435.         (setq data-continue nil)))
  436.  
  437.       (smtpmail-send-data-1 process sending-data)
  438.       )
  439.     )
  440.   )
  441.     
  442.  
  443. (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end)
  444.   "Get address list suitable for smtp RCPT TO: <address>."
  445.   (require 'mail-utils)  ;; pick up mail-strip-quoted-names
  446.   (let
  447.       ((case-fold-search t)
  448.        (simple-address-list "")
  449.        this-line
  450.        this-line-end
  451.        addr-regexp)
  452.     
  453.     (unwind-protect
  454.     (save-excursion
  455.       ;;
  456.       (set-buffer smtpmail-address-buffer) (erase-buffer)
  457.       (insert-buffer-substring smtpmail-text-buffer header-start header-end)
  458.       (goto-char (point-min))
  459.       ;; RESENT-* fields should stop processing of regular fields.
  460.       (save-excursion
  461.         (if (re-search-forward "^RESENT-TO:" header-end t)
  462.         (setq addr-regexp "^\\(RESENT-TO:\\|RESENT-CC:\\|RESENT-BCC:\\)")
  463.           (setq addr-regexp  "^\\(TO:\\|CC:\\|BCC:\\)")))
  464.  
  465.       (while (re-search-forward addr-regexp header-end t)
  466.         (replace-match "")
  467.         (setq this-line (match-beginning 0))
  468.         (forward-line 1)
  469.         ;; get any continuation lines
  470.         (while (and (looking-at "^[ \t]+") (< (point) header-end))
  471.           (forward-line 1))
  472.         (setq this-line-end (point-marker))
  473.         (setq simple-address-list
  474.           (concat simple-address-list " "
  475.               (mail-strip-quoted-names (buffer-substring this-line this-line-end))))
  476.         )
  477.       (erase-buffer)
  478.       (insert-string " ")
  479.       (insert-string simple-address-list)
  480.       (insert-string "\n")
  481.       (subst-char-in-region (point-min) (point-max) 10 ?  t);; newline --> blank
  482.       (subst-char-in-region (point-min) (point-max) ?, ?  t);; comma   --> blank
  483.       (subst-char-in-region (point-min) (point-max)  9 ?  t);; tab     --> blank
  484.  
  485.       (goto-char (point-min))
  486.       ;; tidyness in case hook is not robust when it looks at this
  487.       (while (re-search-forward "[ \t]+" header-end t) (replace-match " "))
  488.  
  489.       (goto-char (point-min))
  490.       (let (recipient-address-list)
  491.         (while (re-search-forward " \\([^ ]+\\) " (point-max) t)
  492.           (backward-char 1)
  493.           (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1))
  494.                          recipient-address-list))
  495.           )
  496.         (setq smtpmail-recipient-address-list recipient-address-list))
  497.  
  498.       )
  499.       )
  500.     )
  501.   )
  502.  
  503.  
  504. (defun smtpmail-do-bcc (header-end)
  505.   "Delete BCC: and their continuation lines from the header area.
  506. There may be multiple BCC: lines, and each may have arbitrarily
  507. many continuation lines."
  508.   (let ((case-fold-search t))
  509.     (save-excursion (goto-char (point-min))
  510.       ;; iterate over all BCC: lines
  511.       (while (re-search-forward "^BCC:" header-end t)
  512.             (delete-region (match-beginning 0) (progn (forward-line 1) (point)))
  513.         ;; get rid of any continuation lines
  514.         (while (and (looking-at "^[ \t].*\n") (< (point) header-end))
  515.           (replace-match ""))
  516.         )
  517.       ) ;; save-excursion
  518.     ) ;; let
  519.   )
  520.  
  521.  
  522.  
  523. (provide 'smtpmail)
  524.  
  525. ;; smtpmail.el ends here
  526.